# user list: send it a message. either type chat with a body of NAMES or a normal message with a subject of IrcUserList

# Single Threaded Simplistic Site

lappend auto_path /home/jdc/lib
lappend auto_path /home/jdc/wubchain_suspend/lib
lappend auto_path /var/www/Wub ;# path to the Site.tcl file

lappend auto_path /home/decoster/www/tcllib-1.11.1/modules
lappend auto_path /home/decoster/www/wub

lappend auto_path c:/Users/decoster/Documents/TclTk/www/tclxmppd
lappend auto_path c:/Users/decoster/Documents/TclTk/www/wub

#lappend auto_path /home/jdc/wub
lappend auto_path . lib

#puts "xml from: [package ifneeded snit [package require xml]]"

set docroot [pwd]/docroot
set home $docroot

package require Site
package require http
package require tdbc
package require tdbc::sqlite3
package require component

###### Application Starts Here

package provide Wubchain 1.0

set API(Wubchain) {
    {Web chat domain}
    number_of_posts {Maximum number of posts to store for a single user (default 1000)}
    database {Name of database for user data (default ./docs/wubchain.sqlite)}
    connect_to_jabber {Connect to XMPPD (jabber) chat (default 1)}
    sys_nick_list {Posts from these nicks are not considered as 'new' posts (default {})}
    bridge_nick_list {Nicks to be interpreted as bridges, not as plain users (default {})}
    in_check_delay {Delay in seconds for client before checking for new posts (default 5)}
    admin_email {Email address of wubchain admin (default {})}
    history_wub_time_diff {Time difference in seconds between time at server logging the history timestamps and time on the on wub server (default 0)}
    resume_interval {Delay in seconds between suspending and resuming of request (default 30)}
    nick_coloring_css_update_interval {Interval in seconds between updates of nick coloring CSS (default 3600)}
    jabber_conference {Jabber conference room to join to (default {})}
    load_history_command {Command to load chat history (default {})}
    load_nick_coloring_css_command {Command to generate nick coloring css (default {})}
    custom_commands_file {File containing code to extend wubchain with custom commands (default {})}
    references_regexps {List of regular expressions and commands to translate parts of a message into a <href> (default {})}
    redirect_commands {Commands to redirect based on message entered by user (default {})}
    redirect_commands_help_command {Command to generate help about redirect messages (default {})}
}

namespace eval ::Wubchain {

    variable version 1.0.0
    variable rcsid {$Id$}

    variable docroot [file join [pwd] docroot]

    variable number_of_posts 1000
    variable database ./docs/wubchain.sqlite
    variable connect_to_jabber 1
    variable sys_nick_list {}
    variable bridge_nick_list {}
    variable in_check_delay 5
    variable admin_email {}
    variable history_wub_time_diff 0
    variable resume_interval 30
    variable jabber_conference {}
    variable wubchain_nick_css_list {}
    variable load_history_command {}
    variable load_nick_coloring_css_command {}
    variable custom_commands_file {}
    variable references_regexps {}
    variable redirect_commands {}
    variable redirect_commands_help_command {}
    variable nick_coloring_css_update_interval 3600

    variable logid 0
    variable log
    variable irc_users
    variable jabber_users
    variable stats
    variable suspended

    set stats(posts_from_jabber) 0
    set stats(posts_from_wubchain) 0
    set stats(gets_from_wubchain) 0
    set stats(last_post_time_stamp) 0

    variable htmlhead {<!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Strict//EN" "http://www.w3.org/TR/xhtml1/DTD/xhtml1.dtd">}
    variable language "en"
    
    variable mobile_head {
	<style type='text/css' media='all'>@import url(/wubchain/css/wubchain_mobile.css);</style>
    }
    
    variable full_head {
	<style type='text/css' media='all'>@import url(/wubchain/css/wubchain_full.css);</style>
    }

    variable head {
	<style type='text/css' media='all'>@import url(/wubchain/css/wubchain.css);</style>
	<style type='text/css' media='all'>@import url(/wubchain/css/wubchain_nick.css);</style>
    }
    
    variable jscripts {
	<script src='/wubchain/scripts/check_new.js' type='text/javascript'></script>
	<script src='/wubchain/scripts/selection.js' type='text/javascript'></script>
    }

    proc sortable {r} {
	foreach js {common css standardista-table-sorting} {
	    dict lappend r -headers [<script> type text/javascript src /wubchain/scripts/$js.js {}]
	}
	dict lappend r -headers [<style> type text/css media all "@import url(/wubchain/css/sorttable.css);"]
	return $r
    }

    proc SmileId { name n triggers } {
	variable IMG
	variable IMGre
	foreach arg $triggers {
	    set IMG($arg) $name
	    if { [string is alnum -strict -failindex i $arg] } {
		lappend ids "\1$arg\2"
	    } elseif { [string is alnum -strict [string index $arg end]] } {
		if {$i > 0} {
		    lappend ids "\1$arg\2"
		} else {
		    lappend ids "\3$arg\2"
		}
	    } else {
		if {$i > 0} {
		    lappend ids "\1$arg"
		} else {
		    lappend ids "\3$arg"
		}
	    }
	}
	set ids [join $ids "\0"]
	set map [list \
		     |   \\|		(   \\(		)   \\)		\[   \\\[	\
		     -   \\-		.   \\.		*   \\*		?    \\?	\
		     \\  \\\\	^   \\^		$   \\$		\1   \\m	\
		     \2  \\M		\3  \\Y		\0  |				\
		    ]
	# If we ever change this to use () capturing, change tkchat::Insert too.
	if { [info exists IMGre] } {
	    append IMGre |[string map $map $ids]
	} else {
	    set IMGre [string map $map $ids]
	}
    }

    SmileId cry 1 {":-(" ":^(" ":("}
    SmileId grrr 1 {"8-(" "8^(" "8(" "8-|" "8^|" "8|"}
    SmileId LOL-anim 1 {LOL lol}
    SmileId mad 1 {">:(" ">:-(" ">:^("}
    SmileId oh 1 {":-o" ":^o" ":o" ":-O" ":^O" ":O"}
    SmileId smile 1 {":-)" ":^)" ":)"}
    SmileId smile-big 1 {":-D" ":^D" ":D"}
    SmileId smile-dork 1 {"<:-)" "<:^)" "<:)"}
    SmileId smile-glasses 1 {"8-)" "8^)" "8)"}
    SmileId smile-tongue-anim 1 {":-p" ":^p" ":p"}
    SmileId smirk-glasses 1 {";/" ";-/" ";^/" ":/" ":-/" ":^/" "8/" "8-/" "8^/"}
    SmileId tongue2 1 {":-P" ":^P" ":P"}
    SmileId updown 1 {"(:" "(^:" "(-:"}
    SmileId wink-anim 1 {";-)" ";^)" ";)"}
    SmileId blush 1 {":-\}" ":^\}" ":8\}" ":\}"}
    SmileId coffee 1 LP
    SmileId lunch 1 {|O| |o| |0|}
    SmileId snooze 1 {zz zzz zzZ zZZ ZZZ ZZ}
    SmileId beer 1 "|_P"
    SmileId cyclops 1 {"O-\]" "O-)" "0-\]" "0-)"}    
    SmileId donuts 1 "donuts"
    SmileId bug 1 {"bug #" "bug#"}
    SmileId wave 2 {~~~ waves}
    SmileId phone 3 {"on the phone"}
    SmileId yawn 3 {yawn yawns}
    SmileId applause 2 {applause applauds}
    SmileId duck 1 {"\\_o<" "\\_O<" "\\_0<" ">o_/" ">O_/" ">0_/" "\\_o=" "\\_O=" "\\_0=" "=o_/" "=O_/" "=0_/" duck ducks}

    proc create_nick_css { } {
	variable load_nick_coloring_css_command
	variable wubchain_nick_css_list {}
	if {[string length $load_nick_coloring_css_command]} {
	    set wubchain_nick_css_list [eval $load_nick_coloring_css_command]
	}
    }

    proc m { mt mn mm {pn ""} {type groupchat}} {
	variable log
	variable logid
	variable current_log_NICK
	variable bridge_nick_list
	variable history_wub_time_diff
	set logonoff 0

	set mm [encoding convertfrom utf-8 $mm]
	set mn [encoding convertfrom utf-8 $mn]

	if {![string length $mn] || [in $bridge_nick_list $mn]} {
	    if {[regexp {<([^>]+)>(.+)} $mm -> tmn tmm]} {
		set mn $tmn
		set mm $tmm
	    } elseif {[regexp {^\*+ ([^ ]+) joins$} $mm -> tmn tmm]} {
		set mn $tmn
		set mm "/me joins"
		set logonoff 1
	    } elseif {[regexp {^([^ ]+) has become available$} $mm -> tmn tmm]} {
		set mn $tmn
		set mm "/me joins"
		set logonoff 1
	    } elseif {[regexp {^\*+ ([^ ]+) leaves$} $mm -> tmn tmm]} {
		set mn $tmn
		set mm "/me leaves"
		set logonoff 1
	    } elseif {[regexp {^([^ ]+) has left$} $mm -> tmn tmm]} {
		set mn $tmn
		set mm "/me leaves"
		set logonoff 1
	    } elseif {[regexp {\* ([^ ]+) (.+)} $mm -> tmn tmm]} {
		set mn $tmn
		set mm "/me $tmm"
	    }
	}
	if {[regexp {^/[Mm][Ee] (.+)} $mm -> mm]} {
	    set prep <i>
	    set postp </i>
	    set emote 1
	} else {
	    set prep ""
	    set postp ""
	    set emote 0
	}
	set amm {}
	set amm {}
	foreach l [split $mm \n] {
	    lappend amm "$prep[armour $l]$postp<br />"
	    lappend hmm "$prep[hfrmt $l]$postp<br />"
	}
	lappend log([prep_username $current_log_NICK]) [list [incr logid] [expr {[clock scan $mt -format {%Y-%m-%dT%H:%M:%SZ}]-$history_wub_time_diff}] [armour $mn] $pn $mm [join $amm] [join $hmm] $emote $logonoff $type]
    }

    proc load_history { NICK } {
	variable log
	variable load_history_command
	variable current_log_NICK $NICK
	variable number_of_posts
	variable history_wub_time_diff
	if {[string length $load_history_command]} {
	    eval $load_history_command $NICK
	}
	m [clock format [expr {[clock seconds]+$history_wub_time_diff}] -format {%Y-%m-%dT%H:%M:%SZ}] "" "<<<<<<<<<< End of history" [prep_username $NICK] chat
	set log([prep_username $NICK]) [lrange $log([prep_username $NICK]) end-[expr {$number_of_posts-1}] end]
	unset -nocomplain current_log_NICK
    }
    
    proc make_href {url} {
	return [<a> href [armour $url] target _blank [armour $url]]
    }

    proc make_iref {emo} {
	variable IMG
	return "<img src='/wubchain/images/$IMG($emo).gif' title='[armour $emo]' />"
    }

    proc sfrmt {msg} {
	variable IMGre
	variable references_regexps
	set i 0
	set hmsg ""
	foreach match [regexp -inline -all -indices -- $IMGre $msg] {
	    lassign $match start end
	    set emo [string range $msg $start $end]
	    append hmsg [armour [string range $msg $i [expr {$start-1}]]]
	    append hmsg [make_iref $emo]
	    set i [expr {$end+1}]
	}	
	if { $i <= [string length $msg] } {
	    append hmsg [armour [string range $msg $i end]]
	}
	return $hmsg
    }

    proc hfrmt {msg} {
	variable references_regexps
	# url's
	set i 0
	set n 0
	set hmsg {}
	foreach match [regexp -inline -all -indices -- {(https?|ftp|news|mailto|file):([^\s:]\S*[^\]\)\s\.,!\?;:'>"])} $msg] { ;# "
	    if { $n % 3 == 0 } {
		lassign $match start end
		set url [string range $msg $start $end]
		lappend hmsg 0 [string range $msg $i [expr {$start-1}]]
		lappend hmsg 1 [make_href $url]
		set i [expr {$end+1}]
	    }
	    incr n
        }
	if { $i <= [string length $msg] } {
	    lappend hmsg 0 [string range $msg $i end]
	}
        # Insert <href> according to regexps specified
        foreach {recmd mkrefcmd} $references_regexps {
	    set tmsg {}
	    foreach {mod txt} $hmsg {
		if {$mod} {
		    lappend tmsg 1 $txt
		} else {
		    set i 0
		    set n 0
		    foreach match [$recmd $txt] {
			if { $n % 2 == 0 } {
			    lassign $match start end
			    set tip [string range $txt $start $end]
			    lappend tmsg 0 [string range $txt $i [expr {$start-1}]]
			    lappend tmsg 1 [$mkrefcmd $tip]
			    set i [expr {$end+1}]
			}
			incr n
		    }
		    if { $i <= [string length $txt] } {
			lappend tmsg 0 [string range $txt $i end]
		    }
		}
	    }
	    set hmsg $tmsg
	}
        # emoticons
	set rmsg {}
	foreach {mod txt} $hmsg {
	    if {$mod} {
		lappend rmsg $txt
	    } else {
		lappend rmsg [sfrmt $txt]
	    }
	}
	return [join $rmsg]
    }

    proc prep_username {u} {
	return [string tolower $u]
    }

    proc in {list element} {
	expr {[lsearch -exact $list $element]>=0}
    }

    proc jabber_enter { nick mode } {
	variable jabber_users
	set jabber_users($nick) $mode
    }

    proc jabber_leave { nick } {
	variable jabber_users
	set jabber_users($nick) offline
    }

    proc jabber_to_wub {nick msg priv type} {

	variable log
	variable logid
	variable irc_fd
	variable stats
	variable irc_users
	variable sys_nick_list
	variable bridge_nick_list
	set emote 0
	if {[regexp {^/[Mm][Ee] (.+)} $msg -> action]} {
	    set emote 1
	    set msg $action
	}

	set logonoff 0

#	puts "j2w: $nick, $msg, $priv, $type"

	if {[string length $msg]==0} {
	    return
	}

	if {$nick eq "ijchain" && $type eq "chat"} {
	    foreach n $msg {
		set irc_users($n) 1
	    }
	} else {
	    if {![string length $nick] || [in $bridge_nick_list $nick]} {
		if {[regexp {<([^>]+)>(.+)} $msg -> nick msg]} {
		} elseif {[regexp {^\*+ ([^ ]+) joins$} $msg -> nick tmm]} {
		    set msg "joins"
		    set logonoff 1
		    set irc_users($nick) 1
		} elseif {[regexp {^([^ ]+) has become available$} $msg -> nick tmm]} {
		    set msg "joins"
		    set logonoff 1
		} elseif {[regexp {^\*+ ([^ ]+) leaves$} $msg -> nick tmm]} {
		    set msg "leaves"
		    set logonoff 1
		    set irc_users($nick) 0
		} elseif {[regexp {^([^ ]+) has left$} $msg -> nick tmm]} {
		    set msg "leaves"
		    set logonoff 1
		}
	    }
	    
	    #	puts "\n\n\nj2w nick=$nick msg=$msg priv=$priv type=$type\n\n\n"
	    
	    set tlog {}
	    lappend tlog [incr logid] [clock seconds] [armour $nick] [armour $priv]
	    set pmsg {}
	    set gmsg {}
	    foreach msgl [split $msg "\n"] {
		if {$emote} {
		    lappend pmsg <i>[armour $msgl]</i>
		    lappend gmsg <i>[hfrmt $msgl]</i>
		} else {
		    lappend pmsg [armour $msgl] 
		    lappend gmsg [hfrmt $msgl]
		}
	    }
	    set plog [join $pmsg "<br />"]
	    append plog "<br />"
	    set glog [join $gmsg "<br />"]
	    append glog "<br />"
	    lappend tlog $msg $plog $glog $emote $logonoff $type
	    lappend log([prep_username $priv]) $tlog
	    incr stats(posts_from_jabber)
	    if {![in $sys_nick_list $nick]} { 
		set stats(last_post_time_stamp) [clock seconds]
	    }
	}
	resume_suspended
    }

    proc sendPage { r C focus innerHtml mobile NICK } {
	variable htmlhead
	variable language
	variable mobile_head
	variable full_head
	variable head
	variable jscripts
	variable jabber_conference
	if { $innerHtml } {
	    set content $C
	} else {
	    set content "${htmlhead}\n"
	    append content "<html xmlns='http://www.w3.org/1999/xhtml' xml:lang='$language' lang='$language'>" \n
	    append content <head> \n
	    if {[dict exists $r -headers]} {
		append content [join [dict get $r -headers] \n] \n
		dict unset r -headers
	    }
	    append content <title>  
	    append content [armour $jabber_conference/$NICK] </title>
	    if {$mobile} {
		append content $mobile_head
	    } else {
		append content $full_head
	    }
	    append content $head
	    append content </head> \n
	    append content <body> \n
	    append content $C \n
	    if {!$mobile} {
		append content $jscripts
	    }
	    append content </body> \n
	    append content </html> \n
	}

	# Send the page
	set r [dict replace $r \
		   -content $content \
		   -raw 1 \
		   content-type text/html]
	set r [Http NoCache $r]
	set r [Http Ok $r]

	return $r
    }

    proc resume_suspended { } {
	variable suspended
	foreach k [array names suspended] {
	    set tsuspended {}
	    foreach {r TS SID ID MSG cor} $suspended($k) {
		Httpd Resume [Http NoCache [Http Ok [/get $r $SID $ID $MSG 1]]]
	    }
	    set suspended($k) {}
	}
    }

    proc select_lang { tag {selected ""} } {
	set ll {
	    en English 
	    ar Arabic
	    bg Bulgarian
	    zh-CN Chinese
	    hr Croatian
	    cs Czech
	    da Danish
	    nl Dutch
	    en English
	    fi Finnish
	    fr French
	    de German
	    el Greek
	    hi Hindi
	    it Italian
	    ja Japanese
	    ko Korean
	    no Norwegian
	    pl Polish
	    pt Portuguese
	    ro Romanian
	    ru Russian
	    es Spanish
	    sv Swedish
	}
	set txt "<select class='cmdinp' name='$tag'>"
	foreach {val lbl} $ll {
	    if {$selected eq $val} {
		append txt "<option value='$val' selected='selected'>$lbl</option>"
	    } else {
		append txt "<option value='$val'>$lbl</option>"
	    }
	}
	append txt "</select>"
    }

    proc select_TZ { tag {selected ""} } {
	variable tzdl
	set txt "<select name='$tag'>"
	foreach val $tzdl {
	    if {$val eq ""} continue
	    if {$selected eq $val} {
		append txt "<option value='$val' selected='selected'>$val</option>"
	    } else {
		append txt "<option value='$val'>$val</option>"
	    }
	}
	append txt "</select>"
    }

    proc control { name href img tip } {
	set R ""
	append R " " [<a> class cmdhref href $href "<img class='cmdimg' title='[armour $tip]' src='/wubchain/images/$img' alt='$name' />"]
	return $R
    }

    proc hform { r d sid msg update mobile } {
	variable logid
	variable in_check_delay
	set R ""
	if {$mobile} {
	    append R "<form id='cpost' action='/wubchain/post' method='post'>"
	    append R "<input id='gobutton' type='submit' value='Go' />"
	    append R " " [<a> href /wubchain/getn?SID=$sid&N=full F]
	    append R " " [<a> href /wubchain/getn?SID=$sid&N=20 20]
	    append R " " [<a> href /wubchain/settings?SID=$sid S]
	    if {[dict get $d admin]} {
		append R " " [<a> href /wubchain/admin?SID=$sid "A"]
	    }
	    append R " "
	    append R "<input id='cmsg' name='MSG' value='[armour $msg]' />"
	    append R "<input id='cid' type='hidden' name='ID' value='$logid' />"
	    append R "<input id='sid' type='hidden' name='SID' value='$sid' />"
	    append R "</form>"
	} else {
	    append R "<div id='post_form'>"
	    append R "<form id='cpost' action='/wubchain/post' method='post'>"
	    append R "<input id='txtbutton' type='button' value='&gt;&gt;' title='Toggle between single or multi line edit' onclick='multi_line()'/>"
	    append R "<span id='msgspan'><input id='cmsg' name='MSG' value='[armour $msg]' /></span>"
	    append R "<span id='txtspan'></span>"
	    append R "<br />"
	    append R "<input class='cmdinp' id='gobutton' type='submit' value='Post/Refresh' title='Post message or refresh screen'/>"
	    append R " " [<a> class cmdhref href /wubchain/getn?SID=$sid&N=full title "Load all messages" All]
	    append R " " [<a> class cmdhref href /wubchain/getn?SID=$sid&N=20 title "Load 20 most recent messages" 20]
	    append R " <input class='cmdinp' id='searchbutton' type='button' value='Google' onclick='google_selection()' title='Google selection'/>"
	    append R "<input class='cmdinp' id='translatebutton' type='button' value='Translate' onclick='translate_selection()' title='Translate selection'/> from "
	    append R [select_lang sl [dict get $d from_language]]
	    append R " to "
	    append R [select_lang tl [dict get $d to_language]]
	    append R [control settings "/wubchain/settings?SID=$sid"         wrench.png        "Edit settings"]
	    if {[dict get $d admin]} {
		append R [control admin   "/wubchain/admin?SID=$sid"         group_edit.png    "User administration"]
	    }
	    append R [control help     "/wubchain/help?SID=$sid"             information.png   "Help"]
	    append R [control online   "/wubchain/status?SID=$sid&ST=online" status_online.png "Set status to 'online'"]
	    append R [control away     "/wubchain/status?SID=$sid&ST=away"   status_away.png   "Set status to 'away'"]
	    append R [control xa       "/wubchain/status?SID=$sid&ST=xa"     status_xa.png     "Set status to 'extended away'"]
	    append R [control dnd      "/wubchain/status?SID=$sid&ST=dnd"    status_dnd.png    "Set status to 'do not disturb'"]
	    append R [control logout   "/wubchain/logout?SID=$sid"           cancel.png        "Log out"]
	    append R "<span id='updatefb'></span>"
	    append R "<input id='cid' type='hidden' name='ID' value='$logid' />"
	    append R "<input id='sid' type='hidden' name='SID' value='$sid' />"
	    append R "</form>"
	    if {$update} {
		append R "
  	            <script type='text/javascript'> 
	            function init() {
		        // quit if this function has already been called
		        if (arguments.callee.done) return;
 
  		        // flag this function so we don't do the same thing twice
		        arguments.callee.done = true;
  
		        try {
                            document.getElementById('post_form').scrollIntoView(false);
		            document.getElementById('cmsg').focus();
                            setTimeout(\"check_new($logid,'[armour $sid]',[expr {$in_check_delay*1000}])\",[expr {$in_check_delay*1000}]);
		        } catch (err) {
		            /* nothing */
		        }
	            };
 
	            /* for Mozilla */
	            if (document.addEventListener) {
		        document.addEventListener(\"DOMContentLoaded\", init, false);
	            }\n"
		append R {	    
	    /* for Internet Explorer */
	    /*@cc_on @*/
	    /*@if (@_win32)
	    document.write("<script defer src='/wubchain/scripts/ie_onload.js'><\/script>");
	    /*@end @*/
	    
	    /* for other browsers */
	    window.onload = init;
}
		append R "</script>\n"
#		append R "<script type='text/javascript'>document.getElementById('cmsg').focus();</script>"
#		append R "\n<script type='text/javascript'>setTimeout(\"check_new($logid,'[armour $sid]','',[expr {$in_check_delay*1000}])\",[expr {$in_check_delay*1000}]);</script>" \n
	    }
	    append R "</div>"
	}
	return $R
    }
    
    proc unescape str {
#	set str [string map [list + { } "\\" "\\\\"] $str]
#	regsub -all -- {%([A-Fa-f0-9][A-Fa-f0-9])} $str {\\u00\1} str
#	set str [subst -novariable -nocommand $str]
	set str [encoding convertfrom utf-8 $str]
	string trim $str
    }

    proc /status { r SID ST } {
	if {[catch {check_sid r $SID} d]} { return $r }
	if {[lsearch {online away xa dnd} $ST] >= 0} {
	    ::/presence [dict get $d username] $ST ""
	}
	return [Http Redir $r "/wubchain/get" SID $SID]
    }

    proc /post { r SID ID MSG } {
	variable log
	variable logid
	variable stats
	variable irc_users
	variable number_of_posts
	variable redirect_commands

	if {[catch {check_sid r $SID} d]} { return $r }

	set NICK [dict get $d username]
	set MSG [unescape $MSG]

	if { ![string is integer -strict $ID] } { set ID 0 }
	set aNICK [armour $NICK]
	if { [string length $MSG] } {
	    foreach redircmd $redirect_commands {
		set redirurl [$redircmd $r $MSG]
		if {[string length $redirurl]} {
		    return [Http Redir $r $redirurl]
		}
	    }
	    set reason ""
	    if {[regexp {^\s*/[Aa][Ff][Kk]\s*(.*)$} $MSG -> reason]} {
		# Away
		::/presence $NICK away $reason
	    } elseif {[regexp {^\s*/[Xx][Aa]\s*(.*)$} $MSG -> reason]} {
		# Extended Away
		::/presence $NICK xa $reason
	    } elseif {[regexp {^\s*/[Dd][Nn][Dd]\s*(.*)$} $MSG -> reason]} {
		# Do not disturb
		::/presence $NICK dnd $reason
	    } elseif {[regexp {^\s*/[Bb][Aa][Cc][Kk]\s*(.*)$} $MSG -> reason]} {
		# Back
		::/presence $NICK online $reason
	    } else {
		if {[regexp {^/[Mm][Ee] (.+)} $MSG -> action]} {
		    ::/post $NICK "/me $action"
		} elseif {[regexp {^/[Mm][Ss][Gg] (\w+) (.*)$} $MSG -> privnick privmsg]} {
		    ::/post $NICK $privmsg $privnick
		    set privmsg "Private message to $privnick: $privmsg"
		    lappend log([prep_username $NICK]) [list [incr logid] [clock seconds] $aNICK $aNICK $privmsg "[armour $privmsg]<br />" "[hfrmt $privmsg]<br />" 0 0 chat]
		} else {
		    ::/post $NICK $MSG
		}
		set log([prep_username $NICK]) [lrange $log([prep_username $NICK]) end-[expr {$number_of_posts-1}] end]
		incr stats(posts_from_wubchain)
		set stats(last_post_time_stamp) [clock seconds]
	    }
	}
	# Redirect
	if {[dict get $d mobile]} {
	    return [Http Redir $r "/wubchain/get#end" SID $SID ID $ID]
	} else {
	    return [Http Redir $r "/wubchain/get" SID $SID ID $ID]
	}
    }

    proc /in { r SID ID MSG IN } {
	variable suspended
	variable logid

	set d [dbLoadUser sid $SID]
	if {![string length $SID] || ![dict exists $d username]} {
	    set R ""
	    append R "0" "(id)\n"
	    return [sendPage $r $R 0 0 0 "" ""]
	}

	if { ![string is integer -strict $ID] } { set ID 0 }
	if {$ID >=$logid} {
	    set suspended([prep_username [dict get $d username]]) [list $r [clock seconds] $SID $ID $MSG [info coroutine]]
#	    puts "Suspending: [info coroutine] $r for [prep_username [dict get $d username]]: $suspended([prep_username [dict get $d username]])"
#	    return {-suspend -1}
	    return [Httpd Suspend $r]
	} else {
	    return [/get $r $SID $ID $MSG 1]
	}
    }

    proc /getn { r SID N } {
	variable number_of_posts
	if {[catch {check_sid r $SID} d]} { return $r }
	if {$N eq "full"} {
	    set N $number_of_posts
	} elseif {![string is integer -strict $N]} {
	    set N 20
	}
	dbUpdate [dict get $d username] lines $N
	if {[dict get $d mobile]} {
	    return [Http Redir $r "/wubchain/get#end" SID $SID]
	} else {
	    return [Http Redir $r "/wubchain/get" SID $SID]
	}
    }

    proc /get { r SID ID MSG IN } {
	variable log
	variable logid
	variable stats
	variable irc_users
	variable jabber_users

	if {[catch {check_sid r $SID} d]} { return $r }

	set NICK  [dict get $d username]
	set pNICK [prep_username [dict get $d username]]
	set GR    [dict get $d emoticons]
	set CNT   [dict get $d lines]
	set MOB   [dict get $d mobile]
	set TSP   [dict get $d time_stamps]
	set HLL   [dict get $d hide_logon_logoff]
	set NC    [dict get $d nick_colors]
	set UL    [dict get $d user_list]
	if { ![string is integer -strict $ID] } { set ID 0 }
	if { ![string is integer -strict $IN] } { set IN 0 }

	set sl [dbLoadSubjects $NICK]

	set aNICK [armour $NICK]

	# Message list

	set totn [llength $log($pNICK)]
	set n 0
	set Cl {}
	for {set currn 0} {$currn < $totn} {incr currn} {
	    lassign [lindex $log($pNICK) end-$currn] id ts nick priv opost post hpost emote logonoff type

#	    puts "$id $ts $nick $priv $opost $post $hpost $emote $logonoff $type"

	    if {!$IN || $id > $ID} {
		if {$HLL && $logonoff} {
		    continue
		}
		set tdclass ""
		switch -exact -- $type {
		    groupchat {
			if {$priv ne "" && $priv ne $pNICK} {
			    continue
			}
		    }
		    chat -
		    normal {
			if {$priv ne $pNICK} {
			    continue
			}
			set tdclass priv_post
		    }
		    error {
			if {$priv ne $pNICK} {
			    continue
			}
			set tdclass error_reply
		    }
		    headline {
			if {$priv ne $pNICK} {
			    continue
			}
			set tdclass headline
		    }
		}

		if {$tdclass eq "" } {
		    if { $NICK eq $nick } {
			set tdclass my_post
		    } elseif { [dict get $d nick_colors] && [string first $NICK $post] >= 0 } {
			set tdclass nick_post
		    } else {
			set found 0
			foreach {id subj} $sl {
			    if {[string match -nocase $subj $opost]} {
				set found 1
				break
			    }
			}
			if {$found} {
			    set tdclass "subj_post"
			} else {
			    set tdclass "no_subj_post"
			}
		    }
		}
		
		set img ""
		if {!$IN && $n == 0} {
		    append img "<img src='/wubchain/images/bookmark.gif' alt='bookmark' />"
		}
		if {$TSP} {
		    if {[string is integer -strict $ts]} {
			set tz [dict get $d time_zone]
			if {[string length $ts]} {
			    if {[catch {clock format $ts -format %H:%M -timezone $tz} t]} {
				set t "[clock format $ts -format %H:%M]*"
			    }
			} else {
			    set t "[clock format $ts -format %H:%M]*"
			}
			set tss "<b>\[$t\]</b> "
		    } else {
			set tss ""
		    }
		} else {
		    set tss ""
		}
		set tC ""

		if {$NC} {
		    set ncpre "<span class='nick_$nick'>"
		    set ncpost "</span>"
		} else {
		    set ncpre ""
		    set ncpost ""
		}

		if {$MOB} {
		    if {[string length $tdclass]} {
			set bgprep "<span class='$tdclass'>"
			set bgpostp "</span>"
		    } else {
			set bgprep ""
			set bgpostp ""
		    }
		    if {$emote} {
			append tC "$img$tss $ncpre$bgprep<b>* $nick</b> "
		    } else {
			append tC "$img$tss $ncpre$bgprep"
			if {[string length $nick]} {
			    append tC "<b>$nick</b>"
			}
			append tC " $bgpostp$bgprep"
		    }
#		    append sj "<a class='userlink' onClick='insert_nick(\"[armour $nick]\");' href='#end'>$ncpre[armour $nick] $mode$ncpost</a>"
		} else {
		    if {[string length $tdclass]} {
			set td "<td class='$tdclass'>"
			set td2 "<td colspan='2' class='$tdclass'>"
		    } else {
			set td "<td>"
			set td2 "<td colspan='2'>"
		    }
		    if {!$IN} {
			append tC "<tr>"
		    }
		    append tC "<td>$img</td>"
		    if {$TSP} {
			append tC "<td>$tss</td>"
		    }
		    if {$emote} {
			append tC "$td2$ncpre<b>*$ncpost " [<a> class userlink href "#end" onClick "insert_nick(\"[armour $nick]\")" $ncpre$nick$ncpost] "</b>$ncpre "
		    } else {
			append tC "$td"
			if {[string length $nick]} {
			    append tC "<b>" [<a> class userlink href "#end" onClick "insert_nick(\"[armour $nick]\")" $ncpre$nick$ncpost] "</b> "
			}
			append tC "</td>$td$ncpre"
		    }
		}
		if { $GR } {
		    append tC "$hpost"
		} else {
		    append tC "$post"
		}
		if {$MOB} {
		    append tC "$bgpostp$ncpost\n"
		} else {
		    append tC "$ncpost</td>"
		    if {!$IN} {
			append tC "</tr>"
		    } 
		    append tC "\n"
		}
		lappend Cl $tC
		incr n
		if {$n >= $CNT} {
		    break
		}
	    }
	}
	set mC ""
	foreach l [lreverse $Cl] {
	    append mC $l
	}

	# User list
	set uC ""
	if {(!$MOB && $UL) || ($MOB && $UL==2)} {
	    set Tj {}
	    foreach k [lsort -dictionary [array names jabber_users]] {
		if {$jabber_users($k) ne "offline"} {
		    set sj "<br />"
		    set mode ""
		    if {$GR} {
			set img statuc_online.png
			if {[lsearch {online away dnd xa} $jabber_users($k)] >= 0} {
			    set img status_$jabber_users($k).png
			}
			append sj "<img src='/wubchain/images/$img' title='$jabber_users($k)' />"
		    } else {
			if {$jabber_users($k) ne "online"} {
			    set mode " ($jabber_users($k))"
			}
		    }
		    
		    if {$NC} {
			set ncpre "<span class='nick_$k'>"
			set ncpost "</span>"
		    } else {
			set ncpre ""
			set ncpost ""
		    }

		    append sj "<a class='userlink' onClick='insert_nick(\"[armour $k]\");' href='#end'>$ncpre[armour $k] $mode$ncpost</a>"
		    lappend Tj $sj
		}
	    }
	    set Ti {}
	    foreach k [lsort -dictionary [array names irc_users]] {
		if {$irc_users($k)} {
		    set sj "<br />"
		    if {$GR} {
			append sj "<img src='/wubchain/images/status_online.png' title='online' />"
		    }
		    append sj "[armour $k]"
		    lappend Ti $sj
		}
	    }
	    append uC "<p><b>[expr {[llength $Tj]+[llength $Ti]}] User online</b></p>\n"
	    append uC "<p><b>[llength $Tj] Jabber users</b>\n[join $Tj]</p>\n"
	    append uC "<p><b>[llength $Ti] IRC users</b>\n[join $Ti]</p>\n"
	}

	# Create response contents
	set C ""
	if {$IN} {
	    if {!$MOB} {
		if {$UL} {
		    append C "$logid" "(id)\n" $uC "(ircandjabberusers)\n" $mC
		} else {
		    append C "$logid" "(id)\n" $mC
		}
	    }
	} elseif {$MOB} {
	    if {$UL==2} {
		append C "<div id='umobmsgs'>" 
		append C $mC
		append C "<p><a id='end'></a></p>"
		append C "<div id='mobcontrols'>"
		append C [hform $r $d $SID "" 1 [dict get $d mobile]]
		append C "</div>"
		append C "</div>"
		append C "<div id='wusers'>\n"
		append C "<div id='users'>\n"
		append C $uC
		append C "</div>\n"
		append C "</div>\n"
	    } else {
		append C "<div id='mobmsgs'>" 
		append C $mC
		append C "<p><a id='end'></a></p>"
		append C "<div id='mobcontrols'>"
		append C [hform $r $d $SID "" 1 [dict get $d mobile]]
		append C "</div>"
		append C "</div>"
	    }
	} else {
	    if {$UL} {
		append C "<div id='wrap'>"
		append C "<div id='umsgs'>"
		append C "<table id='msgstbl' summary=''>"
		append C $mC
		append C "</table>"
		append C "<p><a id='end'></a></p>"
		append C "<div id='controls'>"
		append C [hform $r $d $SID "" 1 [dict get $d mobile]]
		append C "</div>"
		append C "</div>"
		append C "<div id='wusers'>\n"
		append C "<div id='users'>\n"
		append C $uC
		append C "</div></div>\n"
		append C "</div>\n"
	    } else {
		append C "<div id='wrap'>"
		append C "<div id='msgs'>"
		append C "<table id='msgstbl' summary=''>"
		append C $mC
		append C "</table>"
		append C "<p><a id='end'></a></p>"
		append C "<div id='controls'>"
		append C [hform $r $d $SID "" 1 [dict get $d mobile]]
		append C "</div>"
		append C "</div>"
		append C "</div>\n"
	    }
	}

	# Create response
	incr stats(gets_from_wubchain)
	return [sendPage $r $C 1 $IN [dict get $d mobile] $NICK]
    }

    proc dbOpen {} {
	variable database
	variable db wdb
	puts "database=$database / [pwd]"
	tdbc::sqlite3::connection create $db $database
	# Reset all sid's
	$db allrows {UPDATE users SET sid = ""}
	return
    }

    proc statement {name} {
	variable statements
	variable db
	if {![info exists statements($name)]} {
	    switch -exact -- $name {
		"delete_subject_for_username_id" {set sql {DELETE FROM user_subjects WHERE username = :username AND id = :id}}
		"delete_subjects_for_username"   {set sql {DELETE FROM user_subjects WHERE username = :username}}
		"delete_user_for_username"       {set sql {DELETE FROM users WHERE username = :username}}
		"insert_subject_for_username"    {set sql {INSERT INTO user_subjects (username, id, subject) VALUES (:username, :id, :subject)}}
		"max_subject_id_for_username"    {set sql {SELECT MAX(id) FROM user_subjects WHERE username = :username}}
		"subject_for_sid_id"             {set sql {SELECT * FROM users a, user_subjects b WHERE a.username = b.username AND a.sid = :sid AND b.id = :id}}
		"subjects_for_username"          {set sql {SELECT * FROM user_subjects WHERE username = :username}}
		"update_subject_for_username_id" {set sql {UPDATE user_subjects SET subject = :subject WHERE username = :username AND id = :id}}
		"user_for_sid"                   {set sql {SELECT * FROM users WHERE sid = :sid}}
		"user_for_username"              {set sql {SELECT * FROM users WHERE username = :username}}
		"users"                          {set sql {SELECT * FROM users}}
		"users_with_sid"                 {set sql {SELECT * FROM users WHERE length(sid) > 0}}
		"insert_user" {set sql {INSERT INTO users (username, password, email, sid, last_login, emoticons, nick_colors, lines,
							   auto_update, user_list, mobile, from_language, to_language, time_stamps, time_zone,
							   hide_logon_logoff, admin, state, ipaddr, port, user_agent) 
		                        VALUES (:username, :password, :email, :sid, :last_login, :emoticons, :nick_colors, :lines,
						:auto_update, :user_list, :mobile, :from_language, :to_language, :time_stamps, :time_zone,
						:hide_logon_logoff, :admin, :state, :ipaddr, :port, :user_agent)}}
		default { error "Unknown statement '$name'" }
	    }
	    set statements($name) [$db prepare $sql]
	}
	return $statements($name)
    }

    proc dbLoadUser {field val} { 
	set $field $val
	[statement "user_for_$field"] foreach -as dicts d {
	    return $d
	}
	return [dict create]
    }

    proc dbCheckPreparedUser {username} { 
	set pusername [prep_username $username]
	[statement "users"] foreach -as dicts d {
	    if {$pusername eq [prep_username [dict get $d username]]} {
		return 0
	    }
	}
	return 1
    }

    proc dbLoadSubjects {username} {
	set sl {}
	[statement "subjects_for_username"] foreach -as dicts d {
	    lappend sl [dict get $d id] [dict get? $d subject]
	}
	return $sl
    }

    proc dbGetSubject {sid id} {
	[statement "subject_for_sid_id"] foreach -as dicts d {
	    return [dict get $d subject]
	}
	return ""
    }

    proc dbAddSubject {username subject} {
	variable db
	[statement "max_subject_id_for_username"] foreach -as dicts d {
	    puts "MAX $d"
	    if {[dict exists $d MAX(id)]} {
		set id [dict get $d MAX(id)]
	    }
	}
	if {[info exists id] && [string is integer -strict $id]} {
	    incr id
	} else {
	    set id 0
	}
	[statement "insert_subject_for_username"] execute
    }

    proc dbUpdateSubject {username id subject} {
	[statement "update_subject_for_username_id"] execute
    }

    proc dbRemoveSubject {username id} {
	[statement "delete_subject_for_username_id"] execute
    }

    proc dbAdd {args} {
	foreach {k v} $args {set $k $v}
	[statement "insert_user"] execute
    }

    proc dbUsers { } {
	set l {}
	[statement "users"] foreach -as dicts d { lappend l $d }
	return $l
    }
    
    proc dbUpdate {username args} {
	variable db
	set nl {}
	foreach {k v} $args {
	    lappend nl "$k = :$k"
	    set $k $v
	}
	set sql "UPDATE users SET [join $nl ,] WHERE username = :username"
	set stmt [$db prepare $sql]
	$stmt execute
	$stmt close
    }

    proc dbRemoveUser {username} {
	[statement "delete_subjects_for_username"] execute
	[statement "delete_user_for_username"] execute
    }

    proc dbUniqueSid {sid} {
	[statement "user_for_sid"] foreach -as dicts d {
	    return 0
	}
	return 1
    }

    proc check_sid { rnm SID {admin 0}} { 
	upvar $rnm r
	set d [dbLoadUser sid $SID]
	# Removed ip address check to cope with proxies/clients changing ip-address too often: || ([dict get $r -ipaddr] ne [dict get $d ipaddr])
	if {![string length $SID] || ![dict exists $d username] || ([dict get $r user-agent] ne [dict get $d user_agent])} {
	    set R "Failed to load user data: invalid session-id. You need to <a href='/wubchain/login'>Login</a>."
	    set r [sendPage $r $R 0 0 0 ""]
	    return -code error "invalid session-id"
	}
	if {$admin && ![dict get $d admin]} {
	    set R "You need admin privilege to access this page. "
	    append R [<a> href /wubchain/get?SID=$SID "Back to chat."]
	    set r [sendPage $r $R 0 0 0 ""]
	    return -code error "no admin privilege"
	}
	return $d
    }

    proc /login { r } {
	variable admin_email
	variable jabber_conference
	set R "<h1>Login for wubchain connected to $jabber_conference</h1>"
	append R "<form id='cpost' action='/wubchain/login/post' method='get'>"
	append R "<table summary=''>"
	append R "<tr><td>Nick: </td><td><input id='username' name='U' size='20' value='' /></td></tr>"
	append R "<tr><td>Password: </td><td><input id='password' type='password' name='P' size='20' value='' /></td></tr>"
	append R "</table>"
	append R "<p><input id='gobutton' type='submit' value='Login' /></p>"
	append R "</form>"
	append R "<p><br /><br />If you don't have a login yet, you can " [<a> href /wubchain/create create] " one or contact <i>$admin_email</i>.</p>"
	append R [help 0 1]
	set r [sortable $r]	;# include the sortable js
	return [sendPage $r $R 0 0 0 ""]
    }

    proc /login/post { r U P } {
	variable log
	variable logid
	variable user_online
	variable jabber_users
	variable suspended
	variable connect_to_jabber
	set U [string trim [unescape $U]]
	set P [string trim [unescape $P]]
	if {[string trim $U] eq ""} {
	    set R "Login failed: invalid username."
	    return [sendPage $r $R 0 0 0 ""]
	} 
	if {[string trim $P] eq ""} {
	    set R "Login failed: invalid password."
	    return [sendPage $r $R 0 0 0 ""]
	}
	set ufound 0
	set found 0

	set d [dbLoadUser username $U]
	if {![dict exists $d username]} {
	    set R "Login failed: invalid username."
	    return [sendPage $r $R 0 0 0 ""]
	}
	
	if {[dict get $d password] ne $P} {
	    set R "Login failed: invalid password"
	    return [sendPage $r $R 0 0 0 ""]
	}
	 
	if {[dict get $d state] eq "blocked"} {
	    set R "Login failed: access has been blocked."
	    return [sendPage $r $R 0 0 0 ""] 
	}

	while {1} {
	    set sid [format %08x%08x%08x%08x [expr int(rand()*0xffffffff)] [expr int(rand()*0xffffffff)] [expr int(rand()*0xffffffff)] [expr int(rand()*0xffffffff)]]
	    if {[dbUniqueSid $sid]} {
		break
	    }
	}

	if {$connect_to_jabber} {
	    /part [dict get $d username]
	}
	dbUpdate $U sid $sid last_login [clock seconds] ipaddr [dict get $r -ipaddr] port [dict get $r -rport] user_agent [dict get $r user-agent]
	load_history [dict get $d username]
	if {$connect_to_jabber} {
	    /join [dict get $d username]
	    ::/post [dict get $d username] names ijchain
	}
        set jabber_users([dict get $d username]) online
        set suspended([prep_username [dict get $d username]]) {}
	if {[dict get $d mobile]} {
	    return [Http Redir $r "/wubchain/get#end" SID $sid]
	} else {
	    return [Http Redir $r "/wubchain/get" SID $sid]
	}
    }

    proc /settings {r SID} {
	if {[catch {check_sid r $SID} d]} { return $r }
	set C ""
	append C [<h1> "Wubchain settings for user '[dict get $d username]'"]
	append C [<h2> "Settings:"]
	append C "<form id='cpost' action='/wubchain/settings/post' method='get'><table summary=''>"
	append C "<tr><td><b>Email address: </b></td><td><input id='email' name='EM' size='40' value='[dict get $d email]' /></td></tr>"
	append C "<tr><td><b>Number of lines to display: </b></td><td><input id='ccnt' name='CNT' size='10' value='[dict get $d lines]' /></td></tr>"
	append C "<tr><td><b>Use emoticons and detect URLs: </b></td><td><input type='checkbox' id='cgr' name='GR' value='1'"
	if {[dict get $d emoticons]} {
	    append C " checked='checked'" 
	}
	append C " /></td></tr>"
	append C "<tr><td><b>Color posts using colors set in TkChat: </b></td><td><input type='checkbox' id='pcl' name='CN' value='1'"
	if {[dict get $d nick_colors]} {
	    append C " checked='checked'" 
	}
	append C " /></td></tr>"
	append C "<tr><td><b>Auto-update: </b></td><td><input type='checkbox' id='cau' name='AU' value='1'"
	if {[dict get $d auto_update]} {
	    append C " checked='checked'" 
	}
	append C " /></td></tr>"
	append C "<tr><td><b>Show connected users: </b></td><td><input type='radio' id='cul0' name='UL' value='0'"
	if {[dict get $d user_list] == 0} {
	    append C " checked='checked'" 
	}
	append C " /> Never</td></tr>"
	append C "<tr><td></td><td><input type='radio' id='cul1' name='UL' value='1'"
	if {[dict get $d user_list] == 1} {
	    append C " checked='checked'" 
	}
	append C " /> In non-mobile view only</td></tr>"
	append C "<tr><td></td><td><input type='radio' id='cul2' name='UL' value='2'"
	if {[dict get $d user_list] == 2} {
	    append C " checked='checked'" 
	}
	append C " /> In mobile and non-mobile view</td></tr>"
	append C "<tr><td><b>Mobile interface: </b></td><td><input type='checkbox' id='cmb' name='MOB' value='1'"
	if {[dict get $d mobile]} {
	    append C " checked='checked'" 
	}
	append C " /></td></tr>"
	append C "<tr><td><b>Default <i>from</i> language: </b></td><td>"
	append C [select_lang SL [dict get $d from_language]]
	append C "</td></tr>"	
	append C "<tr><td><b>Default <i>to</i> language: </b></td><td>"
	append C [select_lang TL [dict get $d to_language]]
	append C "</td></tr>"	
	append C "<tr><td><b>Show timestamps: </b></td><td><input type='checkbox' id='cts' name='TS' value='1'"
	if {[dict get $d time_stamps]} {
	    append C " checked='checked'" 
	}
	append C " /></td></tr>"
	append C "<tr><td><b>Time zone: </b></td><td>"
	append C [select_TZ TZ [dict get $d time_zone]]
	append C "</td></tr>"	
	append C "<tr><td><b>Hide logon/logoff messages: </b></td><td><input type='checkbox' id='cll' name='LOO' value='1'"
	if {[dict get $d hide_logon_logoff]} {
	    append C " checked='checked'" 
	}
	append C " /></td></tr>"
	append C "</table><div>"
	append C "<input id='sid' type='hidden' name='SID' value='$SID' />"
	append C "<input name='gobutton' id='gobutton' type='submit' value='Save settings' />"
	append C "</div></form>"
	append C [<h2> "Subjects:"]
	set sl [dbLoadSubjects [dict get $d username]]
	if {[llength $sl]} {
	    foreach {id s} $sl {
		dict set td [incr i] [dict create subject $s edit [<a> href /wubchain/editsubject?SID=$SID&S=$id "Edit"] remove [<a> href /wubchain/removesubject?SID=$SID&S=$id "Remove"]]
	    }
	    append C [Html dict2table $td {subject edit remove}]
	}
	append C [<a> href /wubchain/addsubject?SID=$SID "Add subject"]
	append C [<h2> "Links:"]
	append C <ul>
	append C [<li> [<a> href /wubchain/logout?SID=$SID "Log-out"]]
	append C [<li> [<a> href /wubchain/clogin?SID=$SID "Change password"]]
	append C [<li> [<a> href /wubchain/get?SID=$SID "Back to chat"]]
	append C </ul>
	set r [sortable $r]
	return [sendPage $r $C 0 0 0 ""]
    }

    proc /settings/post {r SID EM CNT GR CN AU UL MOB SL TL TZ TS LOO} {
	if {[catch {check_sid r $SID} d]} { return $r }

	if { ![string is integer -strict $CNT] } { set CNT 30 }
	if { ![string is integer -strict $GR] } { set GR 0 }
	if { ![string is integer -strict $CN] } { set CN 0 }
	if { ![string is integer -strict $AU] } { set AU 0 }
	if { ![string is integer -strict $UL] } { set UL 0 }
	if { ![string is integer -strict $MOB] } { set MOB 0 }
	if { ![string is integer -strict $TS] } { set TS 0 }
	if { ![string is integer -strict $LOO] } { set LOO 0 }
	if { ![string length $SL] } { set SL en }
	if { ![string length $TL] } { set TL en }

	dbUpdate [dict get $d username] email $EM emoticons $GR nick_colors $CN lines $CNT auto_update $AU user_list $UL mobile $MOB from_language $SL to_language $TL time_stamps $TS time_zone $TZ hide_logon_logoff $LOO

	if {$MOB} {
	    return [Http Redir $r "/wubchain/get#end" SID $SID]
	} else {
	    return [Http Redir $r "/wubchain/get" SID $SID]
	}
    }

    proc /addsubject {r SID } { 
	if {[catch {check_sid r $SID} d]} { return $r }
	set C ""
	append C [<h1> "Add subject for user '[dict get $d username]'"]
	append C "<form id='cpost' action='/wubchain/addsubject/post' method='get'>"
	append C "New subject specified as <i>string match</i> pattern: <input id='subj' name='S' size='40' />"
	append C "<div>"
	append C "<input id='sid' type='hidden' name='SID' value='$SID' />"
	append C "<input name='gobutton' id='gobutton' type='submit' value='Add subject' />"
	append C "</div></form>"
	return [sendPage $r $C 0 0 0 ""]
    }

    proc /addsubject/post {r SID S} {
	if {[catch {check_sid r $SID} d]} { return $r }
	dbAddSubject [dict get $d username] $S
	return [Http Redir $r "/wubchain/settings" SID $SID]
    }

    proc /editsubject {r SID S} { 
	if {[catch {check_sid r $SID} d]} { return $r }
	set subject [dbGetSubject $SID $S]
	set C ""
	append C [<h1> "Edit subject for user '[dict get $d username]'"]
	append C "<form id='cpost' action='/wubchain/editsubject/post' method='get'>"
	append C "Edit subject specified as <i>string match</i> pattern: <input id='subj' name='NS' size='40' value='[armour $subject]' />"
	append C "<div>"
	append C "<input id='sid' type='hidden' name='SID' value='$SID' />"
	append C "<input id='oldsubject' type='hidden' name='OS' value='$S' />"
	append C "<input name='gobutton' id='gobutton' type='submit' value='Update subject' />"
	append C "</div></form>"
	return [sendPage $r $C 0 0 0 ""]
    }

    proc /editsubject/post {r SID OS NS} {
	if {[catch {check_sid r $SID} d]} { return $r }
	dbUpdateSubject [dict get $d username] $OS $NS
	return [Http Redir $r "/wubchain/settings" SID $SID]
    }

    proc /removesubject {r SID S } { 
	if {[catch {check_sid r $SID} d]} { return $r }
	dbRemoveSubject [dict get $d username] $S
	return [Http Redir $r "/wubchain/settings" SID $SID]
    }

    proc /logout {r SID} {
	variable log
	variable logid
	variable jabber_users
	variable suspended
	if {[catch {check_sid r $SID} d]} { return $r }
	dbUpdate [dict get $d username] sid ""
	unset log([prep_username [dict get $d username]])
	/part [dict get $d username]
        set jabber_users([dict get $d username]) offline
        unset suspended([prep_username [dict get $d username]])
	return [Http Redir $r "/wubchain/login"]
    }

    proc /clogin { r SID } {
	if {[catch {check_sid r $SID} d]} { return $r }
	set R "<h1>Change Wubchain password for user '[dict get $d username]'</h1>"
	append R "<form id='cpost' action='/wubchain/clogin/post' method='get'>"
	append R "<table summary=''>"
	append R "<tr><td>Old password: </td><td><input id='password0' type='password' name='P0' size='20' value='' /></td></tr>"
	append R "<tr><td>New password: </td><td><input id='password1' type='password' name='P1' size='20' value='' /></td></tr>"
	append R "<tr><td>New password: </td><td><input id='password2' type='password' name='P2' size='20' value='' /></td></tr>"
	append R "</table>"
	append R "<p><input id='sid' type='hidden' name='SID' value='$SID' />"
	append R "<input id='gobutton' type='submit' value='Change password' /></p>"
	append R "</form>"
	return [sendPage $r $R 0 0 0 ""]
    }

    proc /clogin/post { r SID P0 P1 P2 } {
	if {[catch {check_sid r $SID} d]} { return $r }

	set P0 [string trim [unescape $P0]]
	set P1 [string trim [unescape $P1]]
	set P2 [string trim [unescape $P2]]

	if {[string trim $P0] eq ""} {
	    set R "Login failed: invalid old password."
	    return [sendPage $r $R 0 0 0 ""]
	}
	if {[string trim $P1] eq ""} {
	    set R "Login failed: invalid new password."
	    return [sendPage $r $R 0 0 0 ""]
	}
	if {[string trim $P2] eq ""} {
	    set R "Login failed: invalid new password."
	    return [sendPage $r $R 0 0 0 ""]
	}
	if {$P1 ne $P2} {
	    set R "Login failed: new passwords are not equal."
	    return [sendPage $r $R 0 0 0 ""]
	}
	if {$P0 eq $P1} {
	    set R "Login failed: password did not change."
	    return [sendPage $r $R 0 0 0 ""]
	}
	if {$P0 ne [dict get $d password]} {
	    set R "Login failed: invalid password."
	    return [sendPage $r $R 0 0 0 ""]
	}

	dbUpdate [dict get $d username] password $P1

	if {[dict get $d mobile]} {
	    return [Http Redir $r "/wubchain/get#end" SID $SID]
	} else {
	    return [Http Redir $r "/wubchain/get" SID $SID]
	}
    }

    proc help { SID loginscreen } {
	variable IMG
	variable wubchain_nick_css_list
	variable jabber_conference
	variable redirect_commands_help_command
	set H [<h1> "Wubchain help"]
	append H [<h2> "Overview"]
	append H "This is a web interface to the Jabber conference <b>$jabber_conference</b>. It's an alternative to Jabber clients like " [<a> href http://wiki.tcl.tk/tkchat target _blank TkChat] ", when all you've got is a browser. It's written in " [<a> href http://www.tcl.tk target _blank Tcl/Tk] ", uses " [<a> href http://wiki.tcl.tk/wub target _blank Wub] " as web server, " [<a> href http://www.sqlite.org target _blank Sqlite] " over " [<a> href http://tdbc.tcl.tk target _blank TDBC] " as database and " [<a> href http://code.google.com/p/tclxmppd target _blank tclxmppd] " to connect to the Jabber conference. Icons are taken from " [<a> href http://wiki.tcl.tk/tkchat target _blank TkChat] " and "  [<a> href http://www.famfamfam.com/lab/icons/silk target _blank famfamfam] ". Source code for wubchain can be found " [<a> href http://code.google.com/p/wubchain target _blank here] "."
	append H "<br /><br />Wubchain has 2 modes:"
	append H <ul>
	append H <li> "Mobile mode:"
	append H <ul>
	append H [<li> "Minimise traffic"]
	append H [<li> "Maximise screen use"]
	append H [<li> "Manual refresh"]
	append H [<li> "Optional color messages according to color set by users in TkChat"]
	append H [<li> "Optional detection of emoticons and URL's"]
	append H [<li> "Optional hiding of log-on / log-off messages"]
	append H [<li> "Optional hiding of time stamps"]
	append H [<li> "Optional list of users connected to the chat, click on a Jabber user to make the message you're typing a private message."]
	append H [<li> "Shortcuts to display full history or last 20 lines."]
	append H </ul></li>
	append H <li> "Full browser mode:"
	append H <ul>
	append H [<li> "Auto-update."]
	append H [<li> "Optional color messages according to color set by users in TkChat."]
	append H [<li> "Optional detection of emoticons and URL's."]
	append H [<li> "Google selected text."]
	append H [<li> "Translate selected text."]
	append H [<li> "Optional hiding of log-on / log-off messages."]
	append H [<li> "Optional timestamps, with adjustable time zone."]
	append H [<li> "Optional list of users connected to the chat, click on a Jabber user to make the message you're typing a private message."]
	append H [<li> "Shortcuts to display full history or last 20 lines."]
	append H </ul></li>
	append H "</ul>"
	append H [<h2> "Reporting errors:"]
	append H "Errors as well as feature request can be reported " [<a> href http://code.google.com/p/wubchain/issues target _blank here] "."
	append H [<h2> "Special commands:"]
	append H "<dl>"
	append H [<dt> "/me [<i> text]"] [<dd> "Send action [<i> text]."]
	append H [<dt> "/msg [<i> nick] [<i> text]"] [<dd> "Send private message [<i> text] to user [<i> nick]. When clicking on a nick name in the right column listing the active chatters, a <tt>/msg [<i> nick]</tt> wil be insert into the edit line."]
	append H [<dt> "/afk [<i> ?message?]"] [<dd> "Set status indicator to [<i> away], with optional message."]
	append H [<dt> "/xa [<i> ?message?]"] [<dd> "Set status indicator to [<i> {extended away}], with optional message."]
	append H [<dt> "/dnd [<i> ?message?]"] [<dd> "Set status indicator to [<i> {do not disturb}], with optional message."]
	append H [<dt> "/back [<i> ?message?]"] [<dd> "Set status indicator to [<i> online], with optional message."]
	if {[string length $redirect_commands_help_command]} {
	    append H [$redirect_commands_help_command]
	}
	append H "</dl>"
	append H [<h2> "Background colors:"]
	append H <ul>
	append H [<li> [<span> class nick_post "Posts containing your username."]]
	append H [<li> [<span> class my_post "Posts you made youself."]]
	append H [<li> [<span> class priv_post "Private posts sent by/to you."]]
	append H [<li> [<span> class subj_post "Posts containing a subject you specified."]]
	append H [<li> [<span> class error_reply "Error messages received from Jabber server."]]
	append H [<li> [<span> class headline "Headline messages."]]
	append H "</ul>"
	if {!$loginscreen} {
	    append H [<h2> "Foreground colors:"]
	    append H "Foreground color of posts is set according to color set by poster in TkChat:<br /><br />"
	    append H <table><tr>
	    set cnt 0
	    foreach i [lsort -dictionary -index 0 $wubchain_nick_css_list] {
		lassign $i n c
		if {$c eq "#000000"} continue
		if {$cnt && (($cnt % 5) == 0)} {
		    append H </tr><tr>
		}
		append H [<td> [<span> class $n [armour "[string range $n 5 end] ($c)"]]]
		incr cnt
	    }
	    append H </tr></table>
	}
	append H [<h2> "User status indictators:"]
	append H "<table summary='status indicators'>"
	foreach i {online away xa dnd} txt {Online Away "Extended away" "Do not disturb"} {
	    append H "<tr><td><img src='/wubchain/images/status_$i.png' title='$txt' /></td><td>$txt</td></tr>"
	}
	append H </table>
	append H [<h2> "Emoticons:"]
	set max 0
	foreach k [array names IMG] {
	    lappend img($IMG($k)) $k
	    if {[llength $img($IMG($k))]>$max} {
		set max [llength $img($IMG($k))]
	    }
	}
	foreach k [lsort -dictionary [array names img]] {
	    set ascii ""
	    foreach i [lsort -dictionary $img($k)] {
		append ascii "[armour $i]&nbsp;&nbsp;&nbsp;&nbsp;"
	    }
	    set d [dict create name $k image [make_iref $i] ascii $ascii]
	    dict set td [incr imgi] $d
	}
	append H [Html dict2table $td {name image ascii}]
	if {!$loginscreen} {
	    append H [<a> href /wubchain/get?SID=$SID "Back to chat"]
	}
	return $H
    }


    proc /help { r SID } {
	variable IMG
	variable wubchain_nick_css_list
	if {[catch {check_sid r $SID} d]} { return $r }
	set H [help $SID 0]
	set r [sortable $r]	;# include the sortable js
	return [sendPage $r $H 0 0 0 ""]
    }

    proc /create { r }  {
	set q [expr {int(rand()*100)}]
	set R "<h1>Create Wubchain login</h1>"
	append R "<form id='cpost' action='/wubchain/create/post' method='get'>"
	append R "<table summary=''>"
	append R "<tr><td>Username: </td><td><input id='username' name='U' size='40' value='' /></td></tr>"
	append R "<tr><td>Email-address: </td><td><input id='email' name='E' size='40' value='' /></td></tr>"
	append R "<tr><td>New password: </td><td><input id='password1' type='password' name='P1' size='40' value='' /></td></tr>"
	append R "<tr><td>New password: </td><td><input id='password2' type='password' name='P2' size='40' value='' /></td></tr>"
	append R "<tr><td>Answer to $q % 8: </td><td><input id='answer' name='A' size='40' value='' /></td></tr>"
	append R "</table>"
	append R "<p><input id='q' type='hidden' name='Q' value='$q' /><input id='gobutton' type='submit' value='Create account' /></p>"
	append R "</form>"
	return [sendPage $r $R 0 0 0 ""]
    }

    proc /create/post { r U E P1 P2 Q A } {
	set U [string trim [unescape $U]]
	set E [string trim [unescape $E]]
	set P1 [string trim [unescape $P1]]
	set P2 [string trim [unescape $P2]]
	set Q [string trim [unescape $Q]]
	set A [string trim [unescape $A]]
	if {$U eq ""} {
	    set R "Could not create account: invalid username."
	    return [sendPage $r $R 0 0 0 ""]
	}
	if {$E eq ""} {
	    set R "Could not create account: invalid email-address"
	    return [sendPage $r $R 0 0 0 ""]
	}
	if {$P1 eq ""} {
	    set R "Could not create account: invalid password"
	    return [sendPage $r $R 0 0 0 ""]
	}
	if {$P2 eq ""} {
	    set R "Could not create account: invalid password"
	    return [sendPage $r $R 0 0 0 ""]
	}
	if {$P2 ne $P1} {
	    set R "Could not create account: passwords do not match"
	    return [sendPage $r $R 0 0 0 ""]
	}
	if {![string is integer -strict $Q] || ![string is integer -strict $A] || ($Q%8) != $A} {
	    set R "Could not create account: invalid answer to security question"
	    return [sendPage $r $R 0 0 0 ""]
	}

	if {![dbCheckPreparedUser $U]} {
	    set R "Could not create account: username already in use"
	    return [sendPage $r $R 0 0 0 ""]	    
	}

	set d [dbLoadUser username $U]
	if {[dict exists $d username]} {
	    set R "Could not create account: username already in use"
	    return [sendPage $r $R 0 0 0 ""]
	}

	dbAdd \
	    username $U \
	    password $P1 \
	    email $E \
	    sid "" \
	    last_login 0 \
	    emoticons 1 \
	    nick_colors 1 \
	    lines 30 \
	    auto_update 1 \
            user_list 1 \
	    mobile 0 \
	    from_language en \
	    to_language en \
	    time_stamps 1 \
	    time_zone :GMT \
	    hide_logon_logoff 0 \
	    admin 0 \
	    state "" \
	    ipaddr "" \
	    port 0 \
	    user_agent ""

	set R ""
	append R "New account was create successfully. " [<a> href /wubchain/login Login] " to access Wubchain."
	return [sendPage $r $R 0 0 0 ""]
    }

    proc /admin {r SID} {
	
	variable stats

	if {[catch {check_sid r $SID 1} d]} { return $r }
	set R [<h1> "Wubchain Admin"]
	append R "<ul>"
	append R [<li> [<a> href #h2users "Users"]]
	append R [<li> [<a> href #h2options "Options"]]
	append R [<li> [<a> href #h2stats "Chat activity"]]
	append R [<li> [<a> href /wubchain/get?SID=$SID "Back to chat"]]
	append R "</ul>"

	append R [<h2> id h2users "Users"]
	set cnt 0
	foreach ud [dbUsers] {
	    dict set ud id [incr $cnt]
	    dict set ud last_login [clock format [dict get $ud last_login] -format "%Y-%m-%d %H:%M:%S"]
	    dict set ud details [<a> href /wubchain/admin/details?SID=$SID&U=[Query encode [dict get $ud username]] details]
	    dict set ud remove [<a> href /wubchain/admin/remove?SID=$SID&U=[Query encode [dict get $ud username]] remove]
	    dict set ud block [<a> href /wubchain/admin/block?SID=$SID&U=[Query encode [dict get $ud username]] block]
	    dict set ud unblock [<a> href /wubchain/admin/unblock?SID=$SID&U=[Query encode [dict get $ud username]] unblock]
	    dict set ud online [expr {[string length [dict get $ud sid]]?"Yes":"No"}]
	    dict set td [incr i] $ud
	}
	if {[info exists td]} {
	    append R [Html dict2table $td {id username online last_login mobile state admin details block unblock remove}]
	}
	append R [<a> href /wubchain/get?SID=$SID "Back to chat"]

	unset -nocomplain ud
	unset -nocomplain td

	append R [<h2> id h2options "Options"]
	foreach {k desc} [lrange $::API(Wubchain) 1 end] {
	    set k [string trim $k]
	    puts "k=$k, desc=$desc"
	    if {[string length $k]} {
		variable $k
		puts  "exists $k? [info exists $k]"
		dict set ud option $k
		dict set ud value [set $k]
		dict set ud desc $desc
		dict set td [incr i] $ud
	    }
	}
	if {[info exists td]} {
	    append R [Html dict2table $td {option value desc}]
	}
	append R [<a> href /wubchain/get?SID=$SID "Back to chat"]

	unset -nocomplain ud
	unset -nocomplain td

	append R [<h2> id h2stats "Chat activity"]
	foreach {k v} [array get stats] {
	    dict set ud parameter $k
	    dict set ud value $v
	    dict set td [incr i] $ud
	}
	append R [Html dict2table $td {parameter value}]
	append R [<a> href /wubchain/get?SID=$SID "Back to chat"]

	set r [sortable $r]	;# include the sortable js

	return [sendPage $r $R 0 0 0 ""]
    }

    proc /admin/details {r SID U} {
	if {[catch {check_sid r $SID 1} d]} { return $r }
	set R ""
	set U [encoding convertfrom utf-8 $U]
	append R [<h1> "Details for user '$U':"]
	set ud [dbLoadUser username $U]

	if {[dict exists $ud username]} {
	    foreach k [lsort -dictionary [dict keys $ud]] {
		dict set td [incr i] [dict create key $k value [dict get $ud $k]]
	    }
	    append R [<h2> "Settings:"]
	    if {[info exists td]} {
		append R [Html dict2table $td {key value}]
	    }
	    append R [<h2> "Subjects:"]
	    set sl [dbLoadSubjects [dict get $ud username]]
	    unset -nocomplain td
	    if {[llength $sl]} {
		foreach {id s} $sl {
		    dict set td [incr i] [dict create subject $s]
		}
		append R [Html dict2table $td {subject}]
	    }
	} else {
	    append R "<p>Unknown user</p>"
	}
	append R [<a> href /wubchain/get?SID=$SID "Back to chat"]
	append R " "
	append R [<a> href /wubchain/admin?SID=$SID "Back to admin"]
	set r [sortable $r]	;# include the sortable js
	return [sendPage $r $R 0 0 0 ""]
    }

    proc /admin/block {r SID U} {
	if {[catch {check_sid r $SID 1} d]} { return $r }
	set U [encoding convertfrom utf-8 $U]
	set ud [dbLoadUser username $U]
	if {[dict exists $ud state]} {
	    dbUpdate $U state blocked sid ""
	}
	return [Http Redir $r "/wubchain/admin" SID $SID]
    }

    proc /admin/unblock {r SID U} {
	if {[catch {check_sid r $SID 1} d]} { return $r }
	set U [encoding convertfrom utf-8 $U]
	set ud [dbLoadUser username $U]
	if {[dict exists $ud state] && [dict get $ud state] eq "blocked"} {
	    dbUpdate $U state ""
	}
	return [Http Redir $r "/wubchain/admin" SID $SID]
    }

    proc /admin/remove {r SID U} {
	if {[catch {check_sid r $SID 1} d]} { return $r }
	set U [encoding convertfrom utf-8 $U]
	set ud [dbLoadUser username $U]
	if {[dict exists $ud username]} {
	    dbRemoveUser $U
	}
	return [Http Redir $r "/wubchain/admin" SID $SID]
    }

    proc /admin/restart {r SID} {
	if {[catch {check_sid r $SID 1} d]} { return $r }
	catch {::component::stop}
	exit
    }

    proc tzd { dir {pfx ""} } { 
	variable tzdl
	foreach f [glob -nocomplain -tail -type f -directory $dir *] {
	    lappend tzdl :$pfx$f
	}
    }

    proc collect_TZ {} {
	variable tzdl {}
	tzd $::tcl_library/tzdata
	foreach d [glob -nocomplain -type d -directory $::tcl_library/tzdata *] {
	    tzd $d [file tail $d]/
	}
	set tzdl [lsort -dictionary $tzdl]
	set tzdl {}
	if {![llength $tzdl]} {
	    set f [open tzd.dat r]
	    set tzdl [split [read $f] \n]
	    close $f
	}
    }

    proc every {ms body} {after $ms [info level 0]; eval $body}
	    
    proc init {args} {
	puts "Site vars [Site var? wubchain]"
	variable {*}[Site var? wubchain]
	variable {*}$args
	variable connect_to_jabber
	variable resume_interval
	variable nick_coloring_css_update_interval
	variable custom_commands_file
	if {$custom_commands_file ne ""} {
	    source $custom_commands_file
	}
	dbOpen
	collect_TZ
	expr srand([clock seconds]) ;# set rand seed for session-id generation
	if {$connect_to_jabber} {
	    ::component::Main
	}
	Wubchain::every [expr {$nick_coloring_css_update_interval*1007}] Wubchain::create_nick_css
	Wubchain::every [expr {$resume_interval*1000}] Wubchain::resume_suspended
    }

    proc new {args} {
	init {*}$args
	return [Direct new {*}$args namespace ::Wubchain]
    }

    proc create {name args} {
	init {*}$args
	return [Direct create $name {*}$args namespace ::Wubchain]
    }

    namespace export -clear *
    namespace ensemble create -subcommands {}
}


Debug off http 20
Debug off socket 10
Debug off direct 10
Debug off cache 10
Debug off slow 10


# Start Site Server(s)
Site start home . config wubchain.config
